perm filename KSORT.PAS[S1,ALS] blob
sn#392601 filedate 1978-11-02 generic text, type T, neo UTF8
(*$L+*)
PROGRAM KSORT(INPUT*,OUTPUT,FILEK*,FILE1,FILE2,FILE3 );
(**********************************************************************)
CONST
MAXSORT= 256;
MAXINDX= 257;
MAXITEM= 160;
MAXKEY= 80;
MAXWORD= 16;
MAXWRDX= 17;
MAXSTACK= 200;
M= 9;
TYPE
SORTINDX= 0 .. MAXINDX;
BYTEINDX= 0 .. 5;
CHARINDX= 0..MAXITEM;
ITEMINDX= 0..MAXITEM;
KEYINDX= 0..MAXKEY;
WORDINDX= 0..MAXWRDX;
TMPINDX= 0 .. 21;
SORTARY= ARRAY [SORTINDX,WORDINDX] OF INTEGER;
CHARARY= ARRAY [SORTINDX,CHARINDX] OF CHAR;
TMPARY= ARRAY [TMPINDX] OF INTEGER;
KEYARY= ARRAY [KEYINDX] OF INTEGER;
FILEK= FILE OF CHAR;
FILE1= FILE OF INTEGER;
FILE2= FILE OF INTEGER;
FILE3= FILE OF INTEGER;
VAR
A: SORTARY;
B: CHARARY;
KEY: KEYARY;
BK: INTEGER;
(**********************************************************************)
(*
PROCEDURE GETKEY(VAR KEY: KEYARY);
LABEL 1,2;
VAR
J: KEYINDX;
K: INTEGER;
C: CHAR;
BEGIN
FOR J:=1 TO 80 DO KEY[J]:=0;
RESET(FILEK);
J:=1; K:=0;
WHILE NOT EOF DO BEGIN
1:
READ(FILEK,C); IF C>='0' THEN IF C<='9' THEN BEGIN
K:=K*10+ORD(C); GOTO 1; END;
IF K<>0 THEN BEGIN
KEY[J]:=K; K:=0; J:=J+1; END;
IF J>80 THEN GOTO 2;
END;
2:
END;
*)
(**********************************************************************)
PROCEDURE LOADA(VAR A: SORTARY; B: CHARARY; KEY: KEYARY; BK: INTEGER);
LABEL 1,2,3,4;
VAR
I: INTEGER;
J: INTEGER;
K: INTEGER;
L: INTEGER;
P: INTEGER;
N: INTEGER;
C: CHAR;
CK: CHAR;
BEGIN
I:=1; J:=1; K:=1; L:=1;
RESET(INPUT);
WHILE NOT EOF DO BEGIN
L:=1;
WHILE NOT EOLN DO BEGIN
READ(INPUT,C);
B[I,L]:=C; L:=L+1; IF L>MAXITEM THEN GOTO 2; END;
FOR L:=L TO MAXITEM DO B[I,L]:=' ';
2:
N:=1; K:=1;
FOR P:=1 TO MAXKEY DO BEGIN
L:=KEY[P]; IF L=0 THEN GOTO 3 ELSE BEGIN
A[I,K]:=A[I,K]*128+ ORD(B[I,L]);
N:=N+1; IF N>5 THEN BEGIN K:=K+1; N:=1; END;
END;
3:
FOR N:=N TO 5 DO A[I,K]:=A[I,K]*128;
FOR K:=K+1 TO MAXWORD DO A[I,K]:=0;
K:=MAXWRDX; A[I,K]:=BK+I;
I:=I+1; K:=1;
READLN(INPUT);
IF I> MAXSORT THEN GOTO 4;
END;
4:
BK:=BK+1;
END;
(**********************************************************************)
PROCEDURE WRTINT(I,LEN: INTEGER);
VAR
POW10: INTEGER;
NEG: BOOLEAN;
DIGS: INTEGER;
TMP: INTEGER;
BEGIN
NEG:=FALSE;
IF I<0 THEN BEGIN
LEN:=LEN-1;
NEG:=TRUE;
I:=-I;
END;
DIGS:=0;
TMP:=I;
POW10:=1;
REPEAT
TMP:=TMP DIV 10;
POW10:=POW10*10;
DIGS:=DIGS+1;
UNTIL TMP=0;
FOR TMP:=LEN DOWNTO DIGS DO BEGIN
WRITE(' ');
END;
IF NEG THEN BEGIN
WRITE('-');
END;
REPEAT
POW10:=POW10 DIV 10;
TMP:=I DIV POW10;
WRITE(CHR(TMP+ORD('0')));
I:=I MOD POW10;
UNTIL POW10=1;
END;
(**********************************************************************)
PROCEDURE TREE(VAR A: SORTARY);
LABEL 1,2,10,11,12,13;
TYPE
KINDX= 0..MAXWRDX;
VAR
I,
J,
L: SORTINDX;
K: WORDINDX;
T: ARRAY [1..MAXWRDX] OF INTEGER;
BEGIN
FOR I:=2 TO MAXINDX DO BEGIN
L:=I;
J:=I;
FOR K:=1 TO MAXWRDX DO T[K]:=A[I,K];
11:
REPEAT
J:=J DIV 2;
K:=1;
IF T[K]<A[J,K] THEN GOTO 1;
WHILE (T[K]=A[J,K] AND K<MAXWRDX) DO K:=K+1;
IF T[K]<=A[J,K] THEN GOTO 1;
FOR K:=1 TO MAXWRDX DO A[L,K]:=A[J,K];
L:=J;
UNTIL J=1;
1:
10:
FOR K:=1 TO MAXWRDX DO A[L,K]:=T[K];
K:=1;
END;
FOR I:=MAXINDX-1 DOWNTO 1 DO BEGIN
FOR K:=1 TO MAXWRDX DO BEGIN
T[K]:=A[I+1,K];
A[I+1,K]:=A[1,K]; END;
K:=1;
L:=1;
J:=2;
WHILE J<=I DO BEGIN
IF J<I THEN BEGIN
K:=1;
WHILE (A[J+1,K]=A[J,K] AND K<MAXWRDX) DO K:=K+1;
IF A[J+1,K]>A[J,K] THEN J:=J+1;
END;
K:=1;
WHILE (A[J,K]=T[K] AND K<MAXWRDX) DO K:=K+1;
IF A[J,K]>T[K] THEN BEGIN
FOR K:=1 TO MAXWRDX DO A[L,K]:=A[J,K];
L:=J;
J:=2*J;
END ELSE GOTO 2;
END;
2:
FOR K:=1 TO MAXWRDX DO A[L,K]:=T[K];
K:=1;
END;
END;
(**********************************************************************)
PROCEDURE QUICK(VAR A: SORTARY);
LABEL 1,2,3,4,5,6,10,11;
CONST
INFINITY= 2147483647;
TYPE
KINDX= 0..16;
VAR
P,
L,
R,
I,
J,
K: KINDX;
T: INTEGER;
TMP,
V: ARRAY [1..WORDMAX] OF INTEGER;
STACK: ARRAY [0 .. MAXSTACK] OF INTEGER;
BEGIN
FOR K:=1 TO 16 DO BEGIN
A[0,K]:=-INFINITY;
A[MAXSORT+1,K]:=INFINITY; END;
P:=0; L:=1; R:=MAXSORT;
1:
I:=L; J:=R+1;
FOR K:=1 TO 16 DO V[K]:=A[L,K];
WHILE I<J DO BEGIN
I:=I+1; K:=1;
10:
WHILE A[I,K]<V[K] DO I:=I+1;
WHILE (A[I,K]=V[K] AND K<16) DO K:=K+1;
IF A[I,K]<V[K] THEN BEGIN I:=I+1; K:=1; GOTO 10; END;
J:=J-1; K:=1;
11:
WHILE A[J,K]>V[K] DO J:=J-1;
WHILE (A[J,K]=V[K] AND K<16)DO K:=K+1;
IF A[J,K]>V[K] THEN BEGIN J:=J-1; K:=1; GOTO 11; END;
K:=1;
FOR K:=1 TO 16 DO BEGIN
TMP[K]:=A[J,K];
A[J,K]:=A[I,K];
A[I,K]:=TMP[K];
END;
END;
FOR K:=1 TO 16 DO BEGIN
TMP[K]:=A[J,K];
A[J,K]:=A[L,K];
A[L,K]:=A[I,K];
A[I,K]:=TMP[K];
END;
IF (R-J)>(J-L) THEN GOTO 3;
IF (J-L)<=M THEN GOTO 5;
IF (R-J)<=M THEN GOTO 4;
P:=P+2;
STACK[P]:=L;
STACK[P+1]:=J-1;
2:
L:=J+1;
GOTO 1;
3:
IF (R-J)<=M THEN GOTO 5;
IF (J-L)<=M THEN GOTO 2;
P:=P+2;
STACK[P]:=J+1;
STACK[P+1]:=R;
4:
R:=J-1;
GOTO 1;
5:
L:=STACK[P];
R:=STACK[P+1];
P:=P-2;
IF P>=0 THEN GOTO 1;
6:
FOR I:=2 TO MAXSORT DO BEGIN
FOR K:=1 TO 16 DO V[K]:=A[I,K];
J:=I-1;
12:
K:=1;
WHILE A[J,K]>V[K] DO BEGIN
FOR K:=1 TO 16 DO A[J+1,K]:=A[J,K];
J:=J-1;
END;
WHILE (A[J+1,K]=V[K] AND K<16) DO K:=K+1;
IF A[J+1,K]>V[K] THEN BEGIN
FOR K:=1 TO 16 DO A[J+1,K]:=A[J,K]; J:=J-1; GOTO 12; END;
FOR K:=1 TO 16 DO A[J+1,K]:=V[K];
K:=1;
END;
END;
(**********************************************************************)
BEGIN
END.
(**********************************************************************)